home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / pathname.lisp < prev    next >
Encoding:
Text File  |  1992-07-28  |  32.4 KB  |  1,036 lines
  1. ;;; -*- Package: LISP -*-
  2. ;;; **********************************************************************
  3. ;;; This code was written as part of the CMU Common Lisp project at
  4. ;;; Carnegie Mellon University, and has been placed in the public domain.
  5. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  6. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  7. ;;;
  8. (ext:file-comment
  9.   "$Header: pathname.lisp,v 1.11 92/06/01 16:24:22 ram Exp $")
  10. ;;;
  11. ;;; **********************************************************************
  12. ;;;
  13. ;;; Machine/filesystem independent pathname functions for CMU Common Lisp.
  14. ;;;
  15. ;;; Written by William Lott
  16. ;;; Earlier version written by Jim Large and Rob MacLachlan
  17. ;;;
  18. ;;; **********************************************************************
  19.  
  20. (in-package "LISP")
  21.  
  22. (export '(pathname pathnamep logical-pathname logical-pathname-p
  23.       parse-namestring merge-pathnames make-pathname
  24.       pathname-host pathname-device pathname-directory pathname-name
  25.       pathname-type pathname-version namestring file-namestring
  26.       directory-namestring host-namestring enough-namestring
  27.       wild-pathname-p pathname-match-p translate-pathname
  28.       translate-logical-pathname logical-pathname-translations
  29.       load-logical-pathname-translations *default-pathname-defaults*))
  30.  
  31. (in-package "EXTENSIONS")
  32. (export '(search-list search-list-defined-p clear-search-list
  33.               enumerate-search-list))
  34.  
  35. (in-package "LISP")
  36.  
  37.  
  38.  
  39. ;;;; Structures and types.
  40.  
  41. (defstruct (pathname
  42.         (:conc-name %pathname-)
  43.         (:print-function %print-pathname)
  44.         (:constructor
  45.          %make-pathname (host device directory name type version))
  46.         (:predicate pathnamep)
  47.         (:make-load-form-fun :just-dump-it-normally))
  48.   "Pathname is the structure of the file pathname.  It consists of a
  49.    host, a device, a directory, a name, and a type."
  50.   (host nil :type (or host null))
  51.   (device nil :type (member nil :unspecific))
  52.   (directory nil :type list)
  53.   (name nil :type (or simple-string pattern null))
  54.   (type nil :type (or simple-string pattern null (member :unspecific)))
  55.   (version nil :type (or integer null (member :newest :wild))))
  56.  
  57. (defun %print-pathname (pathname stream depth)
  58.   (declare (ignore depth))
  59.   (let ((namestring (handler-case (namestring pathname)
  60.               (error nil))))
  61.     (cond (namestring
  62.        (format stream "#p~S" namestring))
  63.       (*print-readably*
  64.        (error "~S Cannot be printed readably." pathname))
  65.       (*print-pretty*
  66.        (pprint-logical-block (stream nil :prefix "#<" :suffix ">")
  67.          (funcall (formatter
  68.                "~2IUnprintable pathname: ~_Host=~S, ~_Device=~S, ~_~
  69.             Directory=~:/LISP:PPRINT-FILL/, ~_Name=~S, ~_~
  70.             Type=~S, ~_Version=~S")
  71.               stream
  72.               (%pathname-host pathname)
  73.               (%pathname-device pathname)
  74.               (%pathname-directory pathname)
  75.               (%pathname-name pathname)
  76.               (%pathname-type pathname)
  77.               (%pathname-version pathname))))
  78.       (t
  79.        (funcall (formatter "#<Unprintable pathname, Host=~S, Device=~S, ~
  80.                 Directory=~S, File=~S, Name=~S, Version=~S>")
  81.             stream
  82.             (%pathname-host pathname)
  83.             (%pathname-device pathname)
  84.             (%pathname-directory pathname)
  85.             (%pathname-name pathname)
  86.             (%pathname-type pathname)
  87.             (%pathname-version pathname))))))
  88.  
  89. (defstruct (host
  90.         (:print-function %print-host))
  91.   (parse (required-argument) :type function)
  92.   (unparse (required-argument) :type function)
  93.   (unparse-host (required-argument) :type function)
  94.   (unparse-directory (required-argument) :type function)
  95.   (unparse-file (required-argument) :type function)
  96.   (unparse-enough (required-argument) :type function)
  97.   (customary-case (required-argument) :type (member :upper :lower)))
  98.  
  99. (defun %print-host (host stream depth)
  100.   (declare (ignore depth))
  101.   (print-unreadable-object (host stream :type t :identity t)))
  102.  
  103.  
  104. ;;;; Patterns
  105.  
  106. (defstruct (pattern
  107.         (:print-function %print-pattern)
  108.         (:make-load-form-fun :just-dump-it-normally)
  109.         (:constructor make-pattern (pieces)))
  110.   (pieces nil :type list))
  111.  
  112. (defun %print-pattern (pattern stream depth)
  113.   (declare (ignore depth))
  114.   (print-unreadable-object (pattern stream :type t)
  115.     (if *print-pretty*
  116.     (let ((*print-escape* t))
  117.       (pprint-fill stream (pattern-pieces pattern) nil))
  118.     (prin1 (pattern-pieces pattern) stream))))
  119.  
  120. (defun pattern= (pattern1 pattern2)
  121.   (declare (type pattern pattern1 pattern2))
  122.   (let ((pieces1 (pattern-pieces pattern1))
  123.     (pieces2 (pattern-pieces pattern2)))
  124.     (and (= (length pieces1) (length pieces2))
  125.      (every #'(lambda (piece1 piece2)
  126.             (typecase piece1
  127.               (simple-string
  128.                (and (simple-string-p piece2)
  129.                 (string= piece1 piece2)))
  130.               (cons
  131.                (and (consp piece2)
  132.                 (eq (car piece1) (car piece2))
  133.                 (string= (cdr piece1) (cdr piece2))))
  134.               (t
  135.                (eq piece1 piece2))))
  136.         pieces1
  137.         pieces2))))
  138.  
  139.  
  140.  
  141. ;;;; Utilities.
  142.  
  143. (defun compare-component (this that)
  144.   (or (eql this that)
  145.       (typecase this
  146.     (simple-string
  147.      (and (simple-string-p that)
  148.           (string= this that)))
  149.     (pattern
  150.      (and (pattern-p that)
  151.           (pattern= this that)))
  152.     (cons
  153.      (and (consp that)
  154.           (compare-component (car this) (car that))
  155.           (compare-component (cdr this) (cdr that)))))))
  156.  
  157.  
  158. ;;;; Logical namestrings
  159.  
  160. #|
  161. (defstruct (logical-host
  162.         (:include host
  163.               (:parse #'parse-logical-namestring)
  164.               ...)
  165.         (:print-function %print-logical-host))
  166.   name
  167.   translations)
  168.  
  169. (deftype logical-pathname ()
  170.   '(satisfies logical-pathname-p))
  171.  
  172. (defun logical-pathname-p (thing)
  173.   "Return T if THING is a LOGICAL-PATHNAME, and NIL if not."
  174.   (and (pathnamep thing)
  175.        (logical-host-p (%pathname-host thing))))
  176. |#
  177.  
  178.  
  179. ;;;; Pathname functions.
  180.  
  181. (defvar *default-pathname-defaults*)
  182.  
  183. (defun pathname= (pathname1 pathname2)
  184.   (and (eq (%pathname-host pathname1)
  185.        (%pathname-host pathname2))
  186.        (compare-component (%pathname-device pathname1)
  187.               (%pathname-device pathname2))
  188.        (compare-component (%pathname-directory pathname1)
  189.               (%pathname-directory pathname2))
  190.        (compare-component (%pathname-name pathname1)
  191.               (%pathname-name pathname2))
  192.        (compare-component (%pathname-type pathname1)
  193.               (%pathname-type pathname2))
  194.        (compare-component (%pathname-version pathname1)
  195.               (%pathname-version pathname2))))
  196.  
  197. (defmacro with-pathname ((var expr) &body body)
  198.   `(let ((,var (let ((,var ,expr))
  199.          (etypecase ,var
  200.            (pathname ,var)
  201.            (string (parse-namestring ,var))
  202.            (stream (parse-namestring (file-name ,var)))))))
  203.      ,@body))
  204.  
  205. (defun %print-namestring-parse-error (condition stream)
  206.   (format stream "Parse error in namestring: ~?~%  ~A~%  ~V@T^"
  207.       (namestring-parse-error-complaint condition)
  208.       (namestring-parse-error-arguments condition)
  209.       (namestring-parse-error-namestring condition)
  210.       (namestring-parse-error-offset condition)))
  211.  
  212. (define-condition namestring-parse-error (error)
  213.   ((complaint :init-form (required-argument))
  214.    (arguments :init-form nil)
  215.    (namestring :init-form (required-argument))
  216.    (offset :init-form (required-argument)))
  217.   (:report %print-namestring-parse-error))
  218.  
  219. (defun %parse-namestring (namestr start end host junk-allowed)
  220.   (declare (type string namestr)
  221.        (type index start end)
  222.        (type host host)
  223.        (values (or null pathname) index))
  224.   (cond (junk-allowed
  225.      (handler-case (%parse-namestring namestr start end host nil)
  226.        (namestring-parse-error (condition)
  227.          (values nil
  228.              (namestring-parse-error-offset condition)))))
  229.     ((simple-string-p namestr)
  230.      (multiple-value-bind
  231.          (new-host device directory file type version)
  232.          (funcall (host-parse host) namestr start end)
  233.        (values (%make-pathname (or new-host host)
  234.                    device directory file type version)
  235.            end)))
  236.     (t
  237.      (%parse-namestring (coerce namestr 'simple-string)
  238.                 start end host nil))))
  239.  
  240. (defun parse-namestring (thing
  241.              &optional host (defaults *default-pathname-defaults*)
  242.              &key (start 0) end junk-allowed)
  243.   (declare (type pathnamelike thing)
  244.        (type (or null host) host)
  245.        (type pathnamelike defaults)
  246.        (type index start)
  247.        (type (or index null) end)
  248.        (type (or null (not null)) junk-allowed)
  249.        (values pathname index))
  250.   (if (stringp thing)
  251.       (%parse-namestring thing start (or end (length thing))
  252.              (or host
  253.                  (with-pathname (defaults defaults)
  254.                    (%pathname-host defaults)))
  255.              junk-allowed)
  256.       (with-pathname (pathname thing)
  257.     (when host
  258.       (unless (eq host (%pathname-host pathname))
  259.         (error "Hosts do not match: ~S and ~S."
  260.            host
  261.            (%pathname-host pathname))))
  262.     (values pathname start))))
  263.  
  264. (defun pathname (thing)
  265.   (declare (type pathnamelike thing))
  266.   (with-pathname (pathname thing)
  267.     pathname))
  268.  
  269. (defun maybe-diddle-case (thing diddle-p)
  270.   (declare (type (or list pattern simple-base-string (member :unspecific))
  271.          thing)
  272.        (values (or list pattern simple-base-string (member :unspecific))))
  273.   (if diddle-p
  274.       (labels ((check-for (pred in)
  275.          (etypecase in
  276.            (pattern
  277.             (dolist (piece (pattern-pieces in))
  278.               (when (typecase piece
  279.                   (simple-string
  280.                    (check-for pred piece))
  281.                   (cons
  282.                    (case (car in)
  283.                  (:character-set
  284.                   (check-for pred (cdr in))))))
  285.             (return t))))
  286.            (list
  287.             (dolist (x in)
  288.               (when (check-for pred x)
  289.             (return t))))
  290.            (simple-base-string
  291.             (dotimes (i (length in))
  292.               (when (funcall pred (schar in i))
  293.             (return t))))
  294.            ((member :unspecific)
  295.             nil)))
  296.            (diddle-with (fun thing)
  297.          (etypecase thing
  298.            (pattern
  299.             (make-pattern
  300.              (mapcar #'(lambda (piece)
  301.                  (typecase piece
  302.                    (simple-base-string
  303.                     (funcall fun thing))
  304.                    (cons
  305.                     (case (car piece)
  306.                       (:character-set
  307.                        (cons :character-set
  308.                          (funcall fun (cdr piece))))
  309.                       (t
  310.                        piece)))
  311.                    (t
  312.                     piece)))
  313.                  (pattern-pieces thing))))
  314.            (list
  315.             (mapcar fun thing))
  316.            (simple-base-string
  317.             (funcall fun thing)))))
  318.     (let ((any-uppers (check-for #'upper-case-p thing))
  319.           (any-lowers (check-for #'lower-case-p thing)))
  320.       (cond ((and any-uppers any-lowers)
  321.          ;; Mixed case, stays the same.
  322.          thing)
  323.         (any-uppers
  324.          ;; All uppercase, becomes all lower case.
  325.          (diddle-with #'string-downcase thing))
  326.         (any-lowers
  327.          ;; All lowercase, becomes all upper case.
  328.          (diddle-with #'string-upcase thing))
  329.         (t
  330.          ;; No letters?  I guess just leave it.
  331.          thing))))
  332.       thing))
  333.  
  334. (defun merge-directories (dir1 dir2 diddle-case)
  335.   (if (or (eq (car dir1) :absolute)
  336.       (null dir2))
  337.       dir1
  338.       (let ((results nil))
  339.     (flet ((add (dir)
  340.          (if (and (eq dir :back)
  341.               results
  342.               (not (eq (car results) :back)))
  343.              (pop results)
  344.              (push dir results))))
  345.       (dolist (dir (maybe-diddle-case dir2 diddle-case))
  346.         (add dir))
  347.       (dolist (dir (cdr dir1))
  348.         (add dir)))
  349.     (reverse results))))
  350.  
  351. (defun merge-pathnames (pathname
  352.             &optional
  353.             (defaults *default-pathname-defaults*)
  354.             (default-version :newest))
  355.   (with-pathname (defaults defaults)
  356.     (let ((pathname (let ((*default-pathname-defaults* defaults))
  357.               (pathname pathname))))
  358.       (let* ((default-host (%pathname-host defaults))
  359.          (pathname-host (%pathname-host pathname))
  360.          (diddle-case
  361.           (and default-host pathname-host
  362.            (not (eq (host-customary-case default-host)
  363.                 (host-customary-case pathname-host))))))
  364.     (%make-pathname (or pathname-host default-host)
  365.             (or (%pathname-device pathname)
  366.                 (maybe-diddle-case (%pathname-device defaults)
  367.                            diddle-case))
  368.             (merge-directories (%pathname-directory pathname)
  369.                        (%pathname-directory defaults)
  370.                        diddle-case)
  371.             (or (%pathname-name pathname)
  372.                 (maybe-diddle-case (%pathname-name defaults)
  373.                            diddle-case))
  374.             (or (%pathname-type pathname)
  375.                 (maybe-diddle-case (%pathname-type defaults)
  376.                            diddle-case))
  377.             (or (%pathname-version pathname)
  378.                 default-version))))))
  379.  
  380. (defun import-directory (directory diddle-case)
  381.   (etypecase directory
  382.     (null nil)
  383.     (list
  384.      (collect ((results))
  385.        (ecase (pop directory)
  386.      (:absolute
  387.       (results :absolute)
  388.       (when (search-list-p (car directory))
  389.         (results (pop directory))))
  390.      (:relative
  391.       (results :relative)))
  392.        (dolist (piece directory)
  393.      (cond ((eq piece :wild)
  394.         (results (make-pattern (list :multi-char-wild))))
  395.            ((eq piece :wild-inferiors)
  396.         (error ":WILD-INFERIORS not supported."))
  397.            ((member piece '(:up :back))
  398.         (results piece))
  399.            ((or (simple-string-p piece) (pattern-p piece))
  400.         (results (maybe-diddle-case piece diddle-case)))
  401.            ((stringp piece)
  402.         (results (maybe-diddle-case (coerce piece 'simple-string)
  403.                         diddle-case)))
  404.            (t
  405.         (error "~S is not allowed as a directory component." piece))))
  406.        (results)))
  407.     (simple-string
  408.      `(:absolute
  409.        ,(maybe-diddle-case directory diddle-case)))
  410.     (string
  411.      `(:absolute
  412.        ,(maybe-diddle-case (coerce directory 'simple-string)
  413.                diddle-case)))))
  414.  
  415. (defun make-pathname (&key (host nil hostp)
  416.                (device nil devp)
  417.                (directory nil dirp)
  418.                (name nil namep)
  419.                (type nil typep)
  420.                (version nil versionp)
  421.                defaults (case :local))
  422.   (declare (type (or host null) host)
  423.        (type (member nil :unspecific) device)
  424.        (type (or list string pattern (member :wild)) directory)
  425.        (type (or null string pattern (member :wild)) name)
  426.        (type (or null string pattern (member :wild)) type)
  427.        (type (or null integer (member :wild :newest)) version)
  428.        (type (or pathnamelike null) defaults)
  429.        (type (member :common :local) case))
  430.   (let* ((defaults (if defaults
  431.                (with-pathname (defaults defaults) defaults)))
  432.      (default-host (if defaults
  433.                (%pathname-host defaults)
  434.                (pathname-host *default-pathname-defaults*)))
  435.      (host (if hostp host default-host))
  436.      (diddle-args (and (eq case :common)
  437.                (eq (host-customary-case host) :lower)))
  438.      (diddle-defaults
  439.       (not (eq (host-customary-case host)
  440.            (host-customary-case default-host)))))
  441.     (macrolet ((pick (var varp field)
  442.          `(cond ((eq ,var :wild)
  443.              (make-pattern (list :multi-char-wild)))
  444.             ((or (simple-string-p ,var)
  445.                  (pattern-p ,var))
  446.              (maybe-diddle-case ,var diddle-args))
  447.             ((stringp ,var)
  448.              (maybe-diddle-case (coerce ,var 'simple-string)
  449.                         diddle-args))
  450.             (,varp
  451.              (maybe-diddle-case ,var diddle-args))
  452.             (defaults
  453.              (maybe-diddle-case (,field defaults)
  454.                         diddle-defaults))
  455.             (t
  456.              nil))))
  457.       (%make-pathname
  458.        host
  459.        (if devp device (if defaults (%pathname-device defaults)))
  460.        (let ((dir (import-directory directory diddle-args)))
  461.      (if (and defaults (not dirp))
  462.          (merge-directories dir
  463.                 (%pathname-directory defaults)
  464.                 diddle-defaults)
  465.          dir))
  466.        (pick name namep %pathname-name)
  467.        (pick type typep %pathname-type)
  468.        (cond
  469.      (versionp version)
  470.      (defaults (%pathname-version defaults))
  471.      (t nil))))))
  472.  
  473. (defun pathname-host (pathname &key (case :local))
  474.   (declare (type pathnamelike pathname)
  475.        (type (member :local :common) case)
  476.        (ignore case))
  477.   (with-pathname (pathname pathname)
  478.     (%pathname-host pathname)))
  479.  
  480. (defun pathname-device (pathname &key (case :local))
  481.   (declare (type pathnamelike pathname)
  482.        (type (member :local :common) case))
  483.   (with-pathname (pathname pathname)
  484.     (maybe-diddle-case (%pathname-device pathname)
  485.                (and (eq case :common)
  486.                 (eq (host-customary-case
  487.                  (%pathname-host pathname))
  488.                 :lower)))))
  489.  
  490. (defun pathname-directory (pathname &key (case :local))
  491.   (declare (type pathnamelike pathname)
  492.        (type (member :local :common) case))
  493.   (with-pathname (pathname pathname)
  494.     (maybe-diddle-case (%pathname-directory pathname)
  495.                (and (eq case :common)
  496.                 (eq (host-customary-case
  497.                  (%pathname-host pathname))
  498.                 :lower)))))
  499.  
  500. (defun pathname-name (pathname &key (case :local))
  501.   (declare (type pathnamelike pathname)
  502.        (type (member :local :common) case))
  503.   (with-pathname (pathname pathname)
  504.     (maybe-diddle-case (%pathname-name pathname)
  505.                (and (eq case :common)
  506.                 (eq (host-customary-case
  507.                  (%pathname-host pathname))
  508.                 :lower)))))
  509.  
  510. (defun pathname-type (pathname &key (case :local))
  511.   (declare (type pathnamelike pathname)
  512.        (type (member :local :common) case))
  513.   (with-pathname (pathname pathname)
  514.     (maybe-diddle-case (%pathname-type pathname)
  515.                (and (eq case :common)
  516.                 (eq (host-customary-case
  517.                  (%pathname-host pathname))
  518.                 :lower)))))
  519.  
  520. (defun pathname-version (pathname)
  521.   (declare (type pathnamelike pathname))
  522.   (with-pathname (pathname pathname)
  523.     (%pathname-version pathname)))
  524.  
  525. (defun namestring (pathname)
  526.   (declare (type pathnamelike pathname))
  527.   (with-pathname (pathname pathname)
  528.     (let ((host (%pathname-host pathname)))
  529.       (if host
  530.       (funcall (host-unparse host) pathname)
  531.       (error
  532.        "Cannot determine the namestring for pathnames with no host:~%  ~S"
  533.        pathname)))))
  534.  
  535. (defun host-namestring (pathname)
  536.   (declare (type pathnamelike pathname))
  537.   (with-pathname (pathname pathname)
  538.     (let ((host (%pathname-host pathname)))
  539.       (if host
  540.       (funcall (host-unparse-host host) pathname)
  541.       (error
  542.        "Cannot determine the namestring for pathnames with no host:~%  ~S"
  543.        pathname)))))
  544.  
  545. (defun directory-namestring (pathname)
  546.   (declare (type pathnamelike pathname))
  547.   (with-pathname (pathname pathname)
  548.     (let ((host (%pathname-host pathname)))
  549.       (if host
  550.       (funcall (host-unparse-directory host) pathname)
  551.       (error
  552.        "Cannot determine the namestring for pathnames with no host:~%  ~S"
  553.        pathname)))))
  554.  
  555. (defun file-namestring (pathname)
  556.   (declare (type pathnamelike pathname))
  557.   (with-pathname (pathname pathname)
  558.     (let ((host (%pathname-host pathname)))
  559.       (if host
  560.       (funcall (host-unparse-file host) pathname)
  561.       (error
  562.        "Cannot determine the namestring for pathnames with no host:~%  ~S"
  563.        pathname)))))
  564.  
  565. (defun enough-namestring (pathname
  566.               &optional (defaults *default-pathname-defaults*))
  567.   (declare (type pathnamelike pathname))
  568.   (with-pathname (pathname pathname)
  569.     (let ((host (%pathname-host pathname)))
  570.       (if host
  571.       (with-pathname (defaults defaults)
  572.         (funcall (host-unparse-enough host) pathname defaults))
  573.       (error
  574.        "Cannot determine the namestring for pathnames with no host:~%  ~S"
  575.        pathname)))))
  576.  
  577.  
  578. ;;;; Wild pathnames.
  579.  
  580. (defun wild-pathname-p (pathname &optional field-key)
  581.   (declare (type pathnamelike pathname)
  582.        (type (member nil :host :device :directory :name :type :version)
  583.          field-key))
  584.   (with-pathname (pathname pathname)
  585.     (ecase field-key
  586.       ((nil)
  587.        (or (wild-pathname-p pathname :host)
  588.        (wild-pathname-p pathname :device)
  589.        (wild-pathname-p pathname :directory)
  590.        (wild-pathname-p pathname :name)
  591.        (wild-pathname-p pathname :type)
  592.        (wild-pathname-p pathname :version)))
  593.       (:host
  594.        (pattern-p (%pathname-host pathname)))
  595.       (:device
  596.        (pattern-p (%pathname-host pathname)))
  597.       (:directory
  598.        (some #'pattern-p (%pathname-directory pathname)))
  599.       (:name
  600.        (pattern-p (%pathname-name pathname)))
  601.       (:type
  602.        (pattern-p (%pathname-type pathname)))
  603.       (:version
  604.        (eq (%pathname-version pathname) :wild)))))
  605.  
  606. (defun pattern-matches (pattern string)
  607.   (declare (type pattern pattern)
  608.        (type simple-string string))
  609.   (let ((len (length string)))
  610.     (labels ((maybe-prepend (subs cur-sub chars)
  611.            (if cur-sub
  612.            (let* ((len (length chars))
  613.               (new (make-string len))
  614.               (index len))
  615.              (dolist (char chars)
  616.                (setf (schar new (decf index)) char))
  617.              (cons new subs))
  618.            subs))
  619.          (matches (pieces start subs cur-sub chars)
  620.            (if (null pieces)
  621.            (if (= start len)
  622.                (values t (maybe-prepend subs cur-sub chars))
  623.                (values nil nil))
  624.            (let ((piece (car pieces)))
  625.              (etypecase piece
  626.                (simple-string
  627.             (let ((end (+ start (length piece))))
  628.               (and (<= end len)
  629.                    (string= piece string
  630.                     :start2 start :end2 end)
  631.                    (matches (cdr pieces) end
  632.                     (maybe-prepend subs cur-sub chars)
  633.                     nil nil))))
  634.                (list
  635.             (ecase (car piece)
  636.               (:character-set
  637.                (and (< start len)
  638.                 (let ((char (schar string start)))
  639.                   (if (find char (cdr piece) :test #'char=)
  640.                       (matches (cdr pieces) (1+ start) subs t
  641.                            (cons char chars))))))))
  642.                ((member :single-char-wild)
  643.             (and (< start len)
  644.                  (matches (cdr pieces) (1+ start) subs t
  645.                       (cons (schar string start) chars))))
  646.                ((member :multi-char-wild)
  647.             (multiple-value-bind
  648.                 (won new-subs)
  649.                 (matches (cdr pieces) start subs t chars)
  650.               (if won
  651.                   (values t new-subs)
  652.                   (and (< start len)
  653.                    (matches pieces (1+ start) subs t
  654.                         (cons (schar string start)
  655.                           chars)))))))))))
  656.       (multiple-value-bind
  657.       (won subs)
  658.       (matches (pattern-pieces pattern) 0 nil nil nil)
  659.     (values won (reverse subs))))))
  660.  
  661. (defun components-match (this that)
  662.   (or (eq this that)
  663.       (typecase this
  664.     (simple-string
  665.      (typecase that
  666.        (pattern
  667.         (values (pattern-matches that this)))
  668.        (simple-string
  669.         (string= this that))))
  670.     (pattern
  671.      (and (pattern-p that)
  672.           (pattern= this that)))
  673.     (cons
  674.      (and (consp that)
  675.           (components-match (car this) (car that))
  676.           (components-match (cdr this) (cdr that))))
  677.     ((member :back :up :unspecific nil)
  678.      (and (pattern-p that)
  679.           (equal (pattern-pieces that) '(:multi-char-wild)))))))
  680.  
  681. (defun pathname-match-p (pathname wildname)
  682.   (with-pathname (pathname pathname)
  683.     (with-pathname (wildname wildname)
  684.       (macrolet ((frob (field)
  685.            `(or (null (,field wildname))
  686.             (components-match (,field pathname)
  687.                       (,field wildname)))))
  688.     (and (frob %pathname-host)
  689.          (frob %pathname-device)
  690.          (frob %pathname-directory)
  691.          (frob %pathname-name)
  692.          (frob %pathname-type)
  693.          (or (null (%pathname-version wildname))
  694.            (eq (%pathname-version wildname) :wild)
  695.            (eql (%pathname-version pathname)
  696.             (%pathname-version wildname))))))))
  697.  
  698. (defun substitute-into (pattern subs)
  699.   (declare (type pattern pattern)
  700.        (type list subs))
  701.   (let ((in-wildcard nil)
  702.     (pieces nil)
  703.     (strings nil))
  704.     (dolist (piece (pattern-pieces pattern))
  705.       (cond ((simple-string-p piece)
  706.          (push piece strings)
  707.          (setf in-wildcard nil))
  708.         (in-wildcard)
  709.         ((null subs))
  710.         (t
  711.          (let ((sub (pop subs)))
  712.            (etypecase sub
  713.          (pattern
  714.           (when strings
  715.             (push (apply #'concatenate 'simple-string
  716.                  (nreverse strings))
  717.               pieces))
  718.           (dolist (piece (pattern-pieces sub))
  719.             (push piece pieces)))
  720.          (simple-string
  721.           (push sub strings))))
  722.          (setf in-wildcard t))))
  723.     (when strings
  724.       (push (apply #'concatenate 'simple-string
  725.            (nreverse strings))
  726.         pieces))
  727.     (if (and pieces
  728.          (simple-string-p (car pieces))
  729.          (null (cdr pieces)))
  730.     (car pieces)
  731.     (make-pattern (nreverse pieces)))))
  732.  
  733. (defun translate-component (source from to)
  734.   (typecase to
  735.     (pattern
  736.      (if (pattern-p from)
  737.      (typecase source
  738.        (pattern
  739.         (if (pattern= from source)
  740.         source
  741.         :error))
  742.        (simple-string
  743.         (multiple-value-bind
  744.         (won subs)
  745.         (pattern-matches from source)
  746.           (if won
  747.           (values (substitute-into to subs))
  748.           :error)))
  749.        (t
  750.         :error))
  751.      source))
  752.     ((member nil :wild)
  753.      source)
  754.     (t
  755.      (if (components-match source from)
  756.      to
  757.      :error))))
  758.  
  759. (defun translate-directories (source from to)
  760.   (if (null to)
  761.       source
  762.       (let ((subs nil))
  763.     (loop
  764.       for from-part in from
  765.       for source-part in source
  766.       do (when (pattern-p from-part)
  767.            (typecase source-part
  768.          (pattern
  769.           (if (pattern= from-part source-part)
  770.               (setf subs (append subs (list source-part)))
  771.               (return-from translate-directories :error)))
  772.          (simple-string
  773.           (multiple-value-bind
  774.               (won new-subs)
  775.               (pattern-matches from-part source-part)
  776.             (if won
  777.             (setf subs (append subs new-subs))
  778.             (return-from translate-directories :error))))
  779.          ((member :back :up)
  780.           (if (equal (pattern-pieces from-part)
  781.                  '(:multi-char-wild))
  782.               (setf subs (append subs (list source-part)))
  783.               (return-from translate-directories :error)))
  784.          (t
  785.           (return-from translate-directories :error)))))
  786.     (mapcar #'(lambda (to-part)
  787.             (if (pattern-p to-part)
  788.             (if (or (eq (car subs) :up) (eq (car subs) :back))
  789.                 (if (equal (pattern-pieces to-part)
  790.                        '(:multi-char-wild))
  791.                 (pop subs)
  792.                 (error "Can't splice ~S into the middle of a ~
  793.                     wildcard pattern."
  794.                        (car subs)))
  795.                 (multiple-value-bind
  796.                 (new new-subs)
  797.                 (substitute-into to-part subs)
  798.                   (setf subs new-subs)
  799.                   new))
  800.             to-part))
  801.         to))))
  802.  
  803. (defun translate-pathname (source from-wildname to-wildname &key)
  804.   (declare (type pathnamelike source from-wildname to-wildname))
  805.   (with-pathname (source source)
  806.     (with-pathname (from from-wildname)
  807.       (with-pathname (to to-wildname)
  808.     (macrolet ((frob (field)
  809.              `(let ((result (translate-component (,field source)
  810.                              (,field from)
  811.                              (,field to))))
  812.             (if (eq result :error)
  813.                 (error "~S doesn't match ~S" source from)
  814.                 result))))
  815.       (%make-pathname (frob %pathname-host)
  816.               (frob %pathname-device)
  817.               (let ((result (translate-directories
  818.                      (%pathname-directory source)
  819.                      (%pathname-directory from)
  820.                      (%pathname-directory to))))
  821.                 (if (eq result :error)
  822.                 (error "~S doesn't match ~S" source from)
  823.                 result))
  824.               (frob %pathname-name)
  825.               (frob %pathname-type)
  826.               (frob %pathname-version)))))))
  827.  
  828.  
  829. ;;;; Search lists.
  830.  
  831. ;;; The SEARCH-LIST structure.
  832. ;;; 
  833. (defstruct (search-list
  834.         (:print-function %print-search-list)
  835.         (:make-load-form-fun
  836.          (lambda (search-list)
  837.            (values `(intern-search-list ',(search-list-name search-list))
  838.                nil))))
  839.   ;;
  840.   ;; The name of this search-list.  Always stored in lowercase.
  841.   (name (required-argument) :type simple-string)
  842.   ;;
  843.   ;; T if this search-list has been defined.  Otherwise NIL.
  844.   (defined nil :type (member t nil))
  845.   ;;
  846.   ;; The list of expansions for this search-list.  Each expansion is the list
  847.   ;; of directory components to use in place of this search-list.
  848.   (%expansions (%primitive c:make-value-cell nil)));  :type list))
  849.  
  850. (defun search-list-expansions (x)
  851.   (%primitive c:value-cell-ref (search-list-%expansions x)))
  852.  
  853. (defun (setf search-list-expansions) (val x)
  854.   (%primitive c:value-cell-set (search-list-%expansions x) val))
  855.  
  856. (defun %print-search-list (sl stream depth)
  857.   (declare (ignore depth))
  858.   (print-unreadable-object (sl stream :type t)
  859.     (write-string (search-list-name sl) stream)))
  860.  
  861. ;;; *SEARCH-LISTS* -- internal.
  862. ;;;
  863. ;;; Hash table mapping search-list names to search-list structures.
  864. ;;; 
  865. (defvar *search-lists* (make-hash-table :test #'equal))
  866.  
  867. ;;; INTERN-SEARCH-LIST -- internal interface.
  868. ;;;
  869. ;;; When search-lists are encountered in namestrings, they are converted to
  870. ;;; search-list structures right then, instead of waiting until the search
  871. ;;; list used.  This allows us to verify ahead of time that there are no
  872. ;;; circularities and makes expansion much quicker.
  873. ;;; 
  874. (defun intern-search-list (name)
  875.   (let ((name (string-downcase name)))
  876.     (or (gethash name *search-lists*)
  877.     (let ((new (make-search-list :name name)))
  878.       (setf (gethash name *search-lists*) new)
  879.       new))))
  880.  
  881. ;;; CLEAR-SEARCH-LIST -- public.
  882. ;;;
  883. ;;; Clear the definition.  Note: we can't remove it from the hash-table
  884. ;;; because there may be pathnames still refering to it.  So we just clear
  885. ;;; out the expansions and ste defined to NIL.
  886. ;;; 
  887. (defun clear-search-list (name)
  888.   "Clear the current definition for the search-list NAME.  Returns T if such
  889.    a definition existed, and NIL if not."
  890.   (let* ((name (string-downcase name))
  891.      (search-list (gethash name *search-lists*)))
  892.     (when (and search-list (search-list-defined search-list))
  893.       (setf (search-list-defined search-list) nil)
  894.       (setf (search-list-expansions search-list) nil)
  895.       t)))
  896.  
  897. ;;; CLEAR-ALL-SEARCH-LISTS -- sorta public.
  898. ;;;
  899. ;;; Again, we can't actually remove the entries from the hash-table, so we
  900. ;;; just mark them as being undefined.
  901. ;;;
  902. (defun clear-all-search-lists ()
  903.   "Clear the definition for all search-lists.  Only use this if you know
  904.    what you are doing."
  905.   (maphash #'(lambda (name search-list)
  906.            (declare (ignore name))
  907.            (setf (search-list-defined search-list) nil)
  908.            (setf (search-list-expansions search-list) nil))
  909.        *search-lists*)
  910.   nil)
  911.  
  912. ;;; EXTRACT-SEARCH-LIST -- internal.
  913. ;;;
  914. ;;; Extract the search-list from PATHNAME and return it.  If PATHNAME
  915. ;;; doesn't start with a search-list, then either error (if FLAME-IF-NONE
  916. ;;; is true) or return NIL (if FLAME-IF-NONE is false).
  917. ;;; 
  918. (defun extract-search-list (pathname flame-if-none)
  919.   (with-pathname (pathname pathname)
  920.     (let* ((directory (%pathname-directory pathname))
  921.        (search-list (cadr directory)))
  922.       (cond ((search-list-p search-list)
  923.          search-list)
  924.         (flame-if-none
  925.          (error "~S doesn't start with a search-list." pathname))
  926.         (t
  927.          nil)))))
  928.  
  929. ;;; SEARCH-LIST -- public.
  930. ;;;
  931. ;;; We have to convert the internal form of the search-list back into a
  932. ;;; bunch of pathnames.
  933. ;;; 
  934. (defun search-list (pathname)
  935.   "Return the expansions for the search-list starting PATHNAME.  If PATHNAME
  936.    does not start with a search-list, then an error is signaled.  If
  937.    the search-list has not been defined yet, then an error is signaled.
  938.    The expansion for a search-list can be set with SETF."
  939.   (with-pathname (pathname pathname)
  940.     (let ((search-list (extract-search-list pathname t))
  941.       (host (pathname-host pathname)))
  942.       (if (search-list-defined search-list)
  943.       (mapcar #'(lambda (directory)
  944.               (make-pathname :host host
  945.                      :directory (cons :absolute directory)))
  946.           (search-list-expansions search-list))
  947.       (error "Search list ~S has not been defined yet." pathname)))))
  948.  
  949. ;;; SEARCH-LIST-DEFINED-P -- public.
  950. ;;; 
  951. (defun search-list-defined-p (pathname)
  952.   "Returns T if the search-list starting PATHNAME is currently defined, and
  953.    NIL otherwise.  An error is signaled if PATHNAME does not start with a
  954.    search-list."
  955.   (with-pathname (pathname pathname)
  956.     (search-list-defined (extract-search-list pathname t))))
  957.  
  958. ;;; %SET-SEARCH-LIST -- public setf method
  959. ;;;
  960. ;;; Set the expansion for the search-list in PATHNAME.  If this would result
  961. ;;; in any circularities, we flame out.  If anything goes wrong, we leave the
  962. ;;; old defintion intact.
  963. ;;; 
  964. (defun %set-search-list (pathname values)
  965.   (let ((search-list (extract-search-list pathname t)))
  966.     (labels
  967.     ((check (target-list path)
  968.        (when (eq search-list target-list)
  969.          (error "That would result in a circularity:~%  ~
  970.              ~A~{ -> ~A~} -> ~A"
  971.             (search-list-name search-list)
  972.             (reverse path)
  973.             (search-list-name target-list)))
  974.        (when (search-list-p target-list)
  975.          (push (search-list-name target-list) path)
  976.          (dolist (expansion (search-list-expansions target-list))
  977.            (check (car expansion) path))))
  978.      (convert (pathname)
  979.        (with-pathname (pathname pathname)
  980.          (when (or (pathname-name pathname)
  981.                (pathname-type pathname)
  982.                (pathname-version pathname))
  983.            (error "Search-lists cannot expand into pathnames that have ~
  984.                a name, type, or ~%version specified:~%  ~S"
  985.               pathname))
  986.          (let ((directory (pathname-directory pathname)))
  987.            (let ((expansion
  988.               (if directory
  989.               (ecase (car directory)
  990.                 (:absolute (cdr directory))
  991.                 (:relative (cons (intern-search-list "default")
  992.                          (cdr directory))))
  993.               (list (intern-search-list "default")))))
  994.          (check (car expansion) nil)
  995.          expansion)))))
  996.       (setf (search-list-expansions search-list)
  997.         (if (listp values)
  998.           (mapcar #'convert values)
  999.           (list (convert values)))))
  1000.     (setf (search-list-defined search-list) t))
  1001.   values)
  1002.  
  1003. ;;; ENUMERATE-SEARCH-LIST -- public.
  1004. ;;; 
  1005. (defmacro enumerate-search-list ((var pathname &optional result) &body body)
  1006.   "Execute BODY with VAR bound to each successive possible expansion for
  1007.    PATHNAME and then return RESULT.  Note: if PATHNAME does not contain a
  1008.    search-list, then BODY is executed exactly once.  Everything is wrapped
  1009.    in a block named NIL, so RETURN can be used to terminate early.  Note:
  1010.    VAR is *not* bound inside of RESULT."
  1011.   (let ((body-name (gensym)))
  1012.     `(block nil
  1013.        (flet ((,body-name (,var)
  1014.         ,@body))
  1015.      (%enumerate-search-list ,pathname #',body-name)
  1016.      ,result))))
  1017.  
  1018. (defun %enumerate-search-list (pathname function)
  1019.   (let ((search-list (extract-search-list pathname nil)))
  1020.     (cond
  1021.      ((not search-list)
  1022.       (funcall function pathname))
  1023.      ((not (search-list-defined search-list))
  1024.       (error "Undefined search list: ~A"
  1025.          (search-list-name search-list)))
  1026.      (t
  1027.       (let ((tail (cddr (pathname-directory pathname))))
  1028.     (dolist (expansion
  1029.          (search-list-expansions search-list))
  1030.       (%enumerate-search-list (make-pathname :defaults pathname
  1031.                          :directory
  1032.                          (cons :absolute
  1033.                                (append expansion
  1034.                                    tail)))
  1035.                   function)))))))
  1036.